#-*-Perl-*-

eval 'exec /emc/sgdb/runperl $0 $*'
    if 0 ;

=head1 NAME

mklist

=head1 SYNOPSIS

mklist mySymbolFile.elf source1.c source2.c source3.s .. sourceN.c 

=head1 DESCRIPTION

merge symbol (elf) file and syren sources to listings 

=head1 AUTHOR

Josef Ezra

=cut

#!perl


BEGIN {
    push @INC, ( $0 =~ m[(.*/)] ) ;
    $ENV{USER}    ||= $ENV{USERNAME}     || 'anonymouse' ;
    $ENV{HOME}    ||= 'C:' ;
    $ENV{PWD}     ||= qx/dir ./ =~ /^ *Directory of (\S+.*?)\S*\n/m ?  $1 : undef ;
    $ENV{PWD}     ||= qx/pwd/   =~ /(\S+.*)/m and (! $!) ? $1 : undef ;
    $ENV{PWD}     ||=  './' ; # good luck
    push @INC, '/emc/sgdb/share' ;
}

# pragmas for all
use 5.6.0 ;
use warnings ;
use strict ;
use integer ;
use bytes ;


use Sgdb::GdbExt ;
use Sgdb::LocalConfig ;
use Sgdb::Utils qw(:DEFAULT
                   get_full_filename
                   localconfig
                   recursive_clean_dir
                   recursive_mkdir
                  ) ;


die <<"HelP" if ! @ARGV or grep /^--?h(?:elp)?$/, @ARGV ;

usage:
  mklist [-m] symmfile source[s]
   -m: display module offsets (instead of function's)
example:
  mklist bin/d61f.elf cache.s cache_rtns.c cache_tags.c
  mklist -m /emc/symdev6/Wednesday/s61f.elf lru.c

HelP




my $moduleoffset ;
my $file = shift ;
$file = shift and $moduleoffset = 1 if $file =~ /^-m$/;
die "file '$file' not exists" unless -e $file ;

my $gdb = new Sgdb::GdbExt localconfig 'parameterize', file => $file ;
die "sgdb: $gdb\n" unless ref $gdb ;
our $tmpdir = "$ENV{HOME}/tmp/.sgdb_scratch/mklist" ;
recursive_clean_dir( $tmpdir ) ;
*Sgdb::ServicePane::dir_scratch = \$tmpdir ;
our @dirs ; 
*Sgdb::ServicePane::source_directories = \@dirs ;
sub ex_gdb_exec_quiet { $gdb -> get( @_ ) }
*Sgdb::CommandPrompt::ex_gdb_exec_quiet = \&ex_gdb_exec_quiet ;
sub ex_gdb_cached { 
    my ($key, $val) = @_ ;

    return unless $gdb ;
    return $gdb -> { $key } = $val if defined $val ;
    return $gdb -> { $key } if exists $gdb -> { $key } ;
    return ;
}
*Sgdb::CommandPrompt::ex_gdb_cached = \&ex_gdb_cached ;

# $_ = $gdb->get( "show emc release" ) ;
$gdb -> { 'is-alive' } = 1 ;
$_ = $gdb -> { 'syren-v' } = localconfig 'get-emc-release', $gdb ;
print ;
($_) = /\"\d+ +(\d+) / ;

if ( $_ and
     0 + $_ and
     $gdb->{file} !~ m{/\.syren/\d+/rel\w+/}
   ) {
  @dirs = ( '  (Syren)' ) ;
}
elsif ( $file =~ m{(.*)/} ) {
  @dirs = ($1 , $1 . '/..' ) ;
}
else {
  @dirs = '.' ;
}


while ( $file = shift ) {

  print qq/
--------------------------------------
DISASSEMBLE FILE: $file
--------------------------------------
/ ;
  my $f = get_full_filename( $file ) ;
  open F, $f or die "can't open $f: $!\n" ;
  my @F = <F> ;

  my ($addr1) = gdb_exec_quiet( "info line $file:1" ) =~ /(0x[\da-f]+)/ ;
  print "*** no code in $file ***\n" and next unless $addr1 ;

  my $end = @F ;

  my ($addr2) = gdb_exec_quiet( "info line $file:$end" )  =~ /(0x[\da-f]+)/ ;
  ( $addr2 ) = gdb_exec_quiet( "info line $file:" . -- $end )  =~ /(0x[\da-f]+)/ while ! $addr2 and $end;
  print "*** bad code in $file ****" and next unless $addr2 ;
  my $disparam = "$addr1 $addr2" ;

  unshift @F, "\n" ;
  my  $range = gdb_exec_quiet( "info orientation $disparam" ) ;
  if(!$range or
     $range =~ /^\s*Undefined info command/ ) {
    $range = gdb_exec_quiet( "mai info lines $disparam" ) ;
  }
  my @ranges = split /^/, $range ;
  push @ranges, '0x0:0' ;
  my @dislines = split /^/, gdb_exec_quiet( "disassemble $disparam " ) ;

  my ($ranges, $raddr, $rline, $next_rline) ;
  $range = shift @ranges ;

  if (@ranges and $range =~ /(0x[\da-f]+):(\d+)/ ) {
    $raddr = $1 ;
    $rline = $2 + 1 ;
  }
  else {
    die 'internal error' ;
    # Algo: this line should cover for standard gdb
  }

  $range = shift @ranges ;
  if ($range and $range =~ /(0x[\da-f]+):(\d+)/ ) {
    $raddr = $1 ;
    $next_rline = $2 + 1 ;
  }
  else {
    print ("***can't determine next range***\n") ;
    $next_rline = $rline  ;
  }

  foreach (@dislines) {

    my ($addr, $offsets, $comm) = /(0x[\da-f]+)(.*?:)(.*\w.*)/ or next ;
    if ($moduleoffset) {
      $offsets = sprintf "0x%05x", eval "$addr - $addr1" ;
      $_ = "$addr <$file+$offsets> : $comm\n" if $offsets ;
    }

    if (eval ("$addr >= $raddr") and
        $range = shift (@ranges) and
        $range =~ /(0x[\da-f]+):(\d+)/ ) {
      $raddr = $1 ;
      $rline = $next_rline ;
      $next_rline = $2 + 1 ;
    }
    $F[$rline] .= $_ ;

  }
  for ( my $i = 1 ; $i < @F ; $i ++ ){ print $i, (' ' x ( 4 - length $i ) ), ' :', $F[$i] }
}
